home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel-075.lha
/
feel0.75
/
Src
/
bootstrap.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-06-18
|
12KB
|
447 lines
/* ******************************************************************** */
/* bootstrap.c Copyright (C) Codemist and University of Bath 1989 */
/* */
/* Rig up the basic Metaclasses/Classes */
/* ******************************************************************** */
/*
* $Id: bootstrap.c,v 1.6 1992/01/17 22:26:18 pab Exp $
*
* $Log: bootstrap.c,v $
* Revision 1.6 1992/01/17 22:26:18 pab
* deleted redundant function
*
* Revision 1.5 1992/01/09 22:28:43 pab
* Fixed for low tag ints
*
* Revision 1.4 1991/12/22 15:13:50 pab
* Xmas revision
*
* Revision 1.3 1991/11/15 13:44:21 pab
* copyalloc rev 0.01
*
* Revision 1.2 1991/09/11 12:07:00 pab
* 11/9/91 First Alpha release of modified system
*
* Revision 1.1 1991/08/12 16:49:27 pab
* Initial revision
*
* Revision 1.2 1991/02/13 18:16:46 kjp
* Weak wrapper class + RCS log headers.
*
*/
#define KJPDBG(x)
/*
* Change Log:
* Version 1, June 1989
*/
#include <stdio.h>
#include "funcalls.h"
#include "defs.h"
#include "structs.h"
#include "global.h"
#include "bootstrap.h"
#include "symboot.h"
#include "allocate.h"
#include "copy.h"
#include "slots.h"
#include "ngenerics.h"
/*
* Should maybe turn all the symbol and class structure mallocs
* into statics...
*/
extern LispObject Basic_Structure;
extern LispObject Primitive_Class;
extern LispObject Thread_Class;
extern LispObject Method_Class;
extern LispObject Macro;
#define N_SLOTS_IN_CLASS N_SLOTS_IN_STRUCT(struct class_structure)
#define N_SLOTS_IN_THREAD N_SLOTS_IN_STRUCT(struct thread_structure)
/*
* Special symbol initialisation...
*/
/*
* 'Place marker' class initialisation.
*/
void gen_class_with_slots(LispObject *stacktop,
LispObject *obj,char *name,
LispObject class,LispObject super,
int local_count)
{
gen_class(stacktop,obj,name,class,super);
(*obj)->CLASS.local_count = super->CLASS.local_count + local_count;
}
/* Also registers a new root */
void gen_class(LispObject *stackbase,
LispObject *obj,char *name,
LispObject class,LispObject super)
{
LispObject sym, xx;
LispObject *stacktop=stackbase+2;
ARG_0(stackbase)=class;
ARG_1(stackbase)=super;
sym = (LispObject) get_symbol(stacktop,name);
STACK_TMP(sym);
*obj = (LispObject) allocate_class(stacktop,NULL);
class=ARG_0(stackbase);
lval_classof(*obj) = class;
UNSTACK_TMP(sym);
(*obj)->CLASS.name = sym;
super=ARG_1(stackbase);
if (super == nil) (*obj)->CLASS.superclasses = nil;
else {
STACK_TMP(*obj);
EUCALLSET_2(xx,Fn_cons,super,nil);
UNSTACK_TMP(*obj);
(*obj)->CLASS.superclasses = xx;
}
super=ARG_1(stackbase);
STACK_TMP(*obj);
EUCALLSET_2(xx, Fn_cons, *obj, (super->CLASS.subclasses==NULL?
nil:super->CLASS.subclasses));
super=ARG_1(stackbase);
super->CLASS.subclasses = xx;
UNSTACK_TMP(*obj);
(*obj)->CLASS.subclasses = nil;
(*obj)->CLASS.slot_table = nil;
STACK_TMP(*obj);
EUCALLSET_2(xx, Fn_cons,(*obj),super->CLASS.precedence);
UNSTACK_TMP(*obj);
(*obj)->CLASS.precedence = xx;
(*obj)->CLASS.local_count = super->CLASS.local_count;
(*obj)->CLASS.slot_list = nil;
(*obj)->CLASS.direct_slot_list = nil;
}
/*
* Non-trivial class initialisation...
*/
void make_class(LispObject *stackbase,
LispObject class,char *name,LispObject meta,
LispObject parent,int local_count)
{
LispObject lispname,tmp;
LispObject *stacktop=stackbase+3;
ARG_0(stackbase)=class;
ARG_1(stackbase)=parent;
ARG_2(stackbase)=meta;
lispname = (LispObject) get_symbol(stacktop,name);
class=ARG_0(stackbase);
meta=ARG_2(stackbase);
lval_classof(class) = meta;
class->CLASS.name = lispname;
parent=ARG_1(stackbase);
tmp = (parent == nil ? nil : EUCALL_2(Fn_cons,parent,nil));
class=ARG_0(stackbase);
parent=ARG_1(stackbase);
class->CLASS.superclasses = tmp;
/* Hack 'cos of mutual reference cases... */
if (parent != nil)
{
if (parent->CLASS.subclasses == NULL)
parent->CLASS.subclasses = nil;
else
{
tmp = EUCALL_2(Fn_cons,class,parent->CLASS.subclasses);
parent=ARG_1(stackbase);
parent->CLASS.subclasses = tmp;
class=ARG_0(stackbase);
}
/* Dang */
}
if (class->CLASS.subclasses == NULL) class->CLASS.subclasses = nil;
if (parent != nil)
tmp = EUCALL_2(Fn_cons,class,parent->CLASS.precedence);
else
tmp = EUCALL_2(Fn_cons,class,nil);
class=ARG_0(stackbase);
parent=ARG_1(stackbase);
class->CLASS.precedence = tmp;
class->CLASS.slot_table = nil;
/* kernel is single inheritance */
class->CLASS.local_count = (parent==nil) ? local_count:
parent->CLASS.local_count + local_count;
class->CLASS.slot_list = nil;
class->CLASS.direct_slot_list = nil;
}
/*
* Useful (?) things for generating lists of lisp objects...
*/
LispObject make_list_1(LispObject *stacktop,LispObject obj)
{
return( EUCALL_2(Fn_cons,obj,nil));
}
LispObject make_list_2(LispObject *stacktop,LispObject obj1,LispObject obj2)
{
LispObject xx;
STACK_TMP(obj1);
xx = make_list_1(stacktop,obj2);
UNSTACK_TMP(obj1);
return( EUCALL_2(Fn_cons,obj1,xx));
}
/*
* Set up all the provided classes + special symbols.
*/
void bootstrap(LispObject *stacktop)
{
/* Reserve space for the classes...
... non garbage and easy for self reference */
/* Root object and root class - self referential... */
Object = (LispObject) allocate_class(stacktop,NULL);
Standard_Class = (LispObject) allocate_class(stacktop,NULL);
add_root(&Object); add_root(&Standard_Class);
/* Slot Description objects */
Slot_Description_Class
= (LispObject) allocate_class(stacktop,NULL);
Slot_Description
= (LispObject) allocate_class(stacktop,NULL);
Local_Slot_Description
= (LispObject) allocate_class(stacktop,NULL);
add_root(&Slot_Description_Class);
add_root(&Slot_Description);
add_root(&Local_Slot_Description);
/* Other good stuff */
Structure_Class
= (LispObject) allocate_class(stacktop,NULL);
/* For symbol bootstrapping... */
Abstract_Class
= (LispObject) allocate_class(stacktop,NULL);
Symbol
= (LispObject) allocate_class(stacktop,NULL);
Null
= (LispObject) allocate_class(stacktop,NULL);
Cons
= (LispObject) allocate_class(stacktop,NULL);
add_root(&Structure_Class);
add_root(&Abstract_Class);
add_root(&Symbol); add_root(&Null);
add_root(&Cons);
/* Get nil... */
EUCALLSET_2(nil, Fn_cons, NULL,NULL);
lval_typeof(nil) = TYPE_NULL;
add_root(&nil);
/* Fill it later... */
/* Symbols and objects needed during class gen */
/**
lisptrue
= (LispObject) system_static_malloc(sizeof(struct symbol_structure));
**/
/* Self evaluating symbols and nil */
(void) make_special_symbol(stacktop,&lisptrue,"t");
(void) make_special_symbol(stacktop,&unbound,"*unbound*");
add_root(&lisptrue);
add_root(&unbound);
/* Begin initialising... */
/* Self referential and kernel classes first... */
/* Note, this initialisation order is importand - parents must have been
initialised before inherited classes may be instantiated... */
/* Object */
make_class( stacktop,
Object,
"object",
Standard_Class,
nil,0 );
/* Standard-Class */
make_class( stacktop,
Standard_Class, /* Class to be made */
"class", /* Name of same */
Standard_Class, /* Class of same */
Object,N_SLOTS_IN_CLASS ); /* Parent */
/* Slot_Description_Class */
make_class( stacktop,
Slot_Description_Class,
"slot-description-class",
Standard_Class,
Standard_Class, 0);
/* Slot_Description */
make_class( stacktop,
Slot_Description,
"slot-description",
Slot_Description_Class,
Object, N_SLOTS_IN_SD_CLASS );
/* Local_Slot_Description */
make_class( stacktop,
Local_Slot_Description,
"local-slot-description",
Slot_Description_Class,
Slot_Description, 0 );
make_class( stacktop,
Structure_Class,
"structure-class",
Standard_Class,
Standard_Class, 0 );
make_class( stacktop,
Abstract_Class,
"abstract-class",
Standard_Class,
Standard_Class, 0);
gen_class(stacktop,&Primitive_Class,
"primitive-class",Standard_Class,Standard_Class);
add_root(&Primitive_Class);
gen_class(stacktop,&Thread_Class,
"thread-class",Standard_Class,Standard_Class);
add_root(&Thread_Class);
/* Used in class generation... */
make_class(stacktop,Cons,"pair",Primitive_Class,Object,0);
make_class(stacktop,Null,"null",Primitive_Class,Object,0);
make_class(stacktop,Symbol,"symbol",Primitive_Class,Object,0);
/* The "place marker" classes */
/* Metas */
gen_class(stacktop,&Funcallable_Object_Class,"funcallable-object-class",
Standard_Class,Standard_Class);
add_root(&Funcallable_Object_Class);
gen_class(stacktop,&Pair_Class,"pair-class",Standard_Class,Standard_Class);
add_root(&Pair_Class);
gen_class(stacktop,&Unpredictable_Fixed_Size_Class,"unpredictable-fixed-size-class",
Standard_Class,Standard_Class);
add_root(&Unpredictable_Fixed_Size_Class);
gen_class(stacktop,&Variable_Size_Keyed_Class,"variable-size-keyed-class",
Standard_Class,Standard_Class);
add_root(&Variable_Size_Keyed_Class);
gen_class(stacktop,&Method_Class,"method-class",Standard_Class,Standard_Class);
add_root(&Method_Class);
gen_class(stacktop,&Generic_Class,"generic-class",
Standard_Class,Funcallable_Object_Class);
add_root(&Generic_Class);
gen_class(stacktop,&Number, "number", Primitive_Class,Object);
add_root(&Number);
gen_class(stacktop,&Complex, "complex", Primitive_Class,Number);
add_root(&Complex);
gen_class(stacktop,&Real, "real", Primitive_Class,Complex);
add_root(&Real);
gen_class(stacktop,&Rational, "rational", Primitive_Class,Real);
add_root(&Rational);
gen_class(stacktop,&Integer, "integer", Primitive_Class,Rational);
add_root(&Integer);
gen_class(stacktop,&Character,"character",Primitive_Class,Object);
add_root(&Character);
gen_class(stacktop,&String, "string", Primitive_Class,Object);
add_root(&String);
gen_class_with_slots(stacktop,&Thread, "thread",Thread_Class,Object,
N_SLOTS_IN_THREAD);
add_root(&Thread);
gen_class(stacktop,&Function, "function", Funcallable_Object_Class,Object);
add_root(&Function);
gen_class(stacktop,&Continue, "continuation",Funcallable_Object_Class,Function);
add_root(&Continue);
gen_class_with_slots(stacktop,&Generic,
"generic-function",Generic_Class,Function,
N_SLOTS_IN_GENERIC_CLASS);
add_root(&Generic);
gen_class_with_slots(stacktop,&Method, "method", Method_Class,Object,
N_SLOTS_IN_METHOD_CLASS);
add_root(&Method);
gen_class(stacktop,&Macro, "macro", Funcallable_Object_Class,Function);
add_root(&Macro);
gen_class(stacktop,&Vector,"vector",Primitive_Class,Object);
add_root(&Vector);
gen_class(stacktop,&Table,"table",Primitive_Class,Object);
add_root(&Table);
gen_class(stacktop,&Weak_Wrapper,"weak-wrapper",Primitive_Class,Object);
add_root(&Weak_Wrapper);
/* Do nil... */
#ifdef WITH_SMALL_CONSES
nil->CONS.car = nil;
nil->CONS.cdr = nil;
#else
lval_classof(nil) = Null;
nil->CONS.car = nil;
nil->CONS.cdr = nil;
#endif
{
extern LispObject boot_thread;
lval_classof(boot_thread)=Thread;
}
gen_class(stacktop,&Basic_Structure,"structure",Structure_Class,Object);
add_root(&Basic_Structure);
allocate_static_integers(stacktop);
}